home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / Other Langs / Tickle-4.0 (tcl) / tcl / extend / src / tclXstartup.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-11-18  |  16.1 KB  |  520 lines  |  [TEXT/MPS ]
  1. #ifdef MPW
  2. #    pragma segment TCLExtend
  3. #endif
  4.  
  5. /*
  6.  * tclXstartup.c --
  7.  *
  8.  * Startup code for the Tcl shell and other interactive applications.  Also
  9.  * create special commands used just by Tcl shell features.
  10.  *-----------------------------------------------------------------------------
  11.  * Copyright 1991-1993 Karl Lehenbauer and Mark Diekhans.
  12.  *
  13.  * Permission to use, copy, modify, and distribute this software and its
  14.  * documentation for any purpose and without fee is hereby granted, provided
  15.  * that the above copyright notice appear in all copies.  Karl Lehenbauer and
  16.  * Mark Diekhans make no representations about the suitability of this
  17.  * software for any purpose.  It is provided "as is" without express or
  18.  * implied warranty.
  19.  *-----------------------------------------------------------------------------
  20.  * $Id: tclXstartup.c,v 2.17 1993/08/31 23:03:20 markd Exp $
  21.  *-----------------------------------------------------------------------------
  22.  */
  23.  
  24. #include "tclExtdInt.h"
  25. #include "patchlevel.h"
  26.  
  27. extern char *optarg;
  28. extern int   optind, opterr;
  29.  
  30. typedef struct tclParms_t {
  31.     int       execFile;      /* Run the specified file. (no searching)       */
  32.     int       execCommand;   /* Execute the specified command.               */
  33.     unsigned  options;       /* Startup options.                             */
  34.     char     *execStr;       /* Command file or command to execute.          */
  35.     } tclParms_t;
  36.  
  37. /*
  38.  * Prototypes of internal functions.
  39.  */
  40. static void
  41. ParseCmdArgs _ANSI_ARGS_((Tcl_Interp  *interp,
  42.                           int          argc,
  43.                           char       **argv,
  44.                           tclParms_t  *tclParmsPtr));
  45.  
  46. static void
  47. MergeMasterDirPath _ANSI_ARGS_((char        *dir,
  48.                                 char        *version1,
  49.                                 char        *version2,
  50.                                 Tcl_DString *dirPathPtr));
  51.  
  52. /*
  53.  *-----------------------------------------------------------------------------
  54.  *
  55.  * Tcl_ErrorAbort --
  56.  *
  57.  * Display error information and abort when an error is returned in the
  58.  * interp->result.
  59.  *
  60.  * Parameters:
  61.  *   o interp - A pointer to the interpreter, should contain the
  62.  *     error message in `result'.
  63.  *   o noStackDump - If TRUE, then the procedure call stack will not be
  64.  *     displayed.
  65.  *   o exitCode - The code to pass to exit.
  66.  *-----------------------------------------------------------------------------
  67.  */
  68.  
  69. void
  70. Tcl_ErrorAbort (interp, noStackDump, exitCode)
  71.     Tcl_Interp  *interp;
  72.     int          noStackDump;
  73.     int          exitCode;
  74. {
  75.     char *errorStack;
  76.  
  77.     fflush (stdout);
  78. #ifdef macintosh
  79.     mac_fprintf(stderr, "Error: %s\n", interp->result);
  80. #else
  81.     fprintf (stderr, "Error: %s\n", interp->result);
  82. #endif
  83.  
  84.     if (noStackDump == 0) {
  85.         errorStack = Tcl_GetVar (interp, "errorInfo", 1);
  86.         if (errorStack != NULL)
  87. #ifdef macintosh
  88.             mac_fprintf(stderr, "%s\n", errorStack);
  89. #else
  90.             fprintf (stderr, "%s\n", errorStack);
  91. #endif
  92.     }
  93.     exit (exitCode);
  94. }
  95.  
  96. /*
  97.  *-----------------------------------------------------------------------------
  98.  * MergeMasterDirPath --
  99.  *
  100.  *   Merge mastter directory components and into a path name.  
  101.  *
  102.  * Parameters:
  103.  *   o dir (I) - The directory name.
  104.  *   o version1, version2 - Two part version number forming a directory under
  105.  *     dir.  Either maybe NULL.
  106.  *   o dirPathPtr (O) - Dynamic string containing the directory path.  Will
  107.  *     be initialized.
  108.  *-----------------------------------------------------------------------------
  109.  */
  110. static void
  111. MergeMasterDirPath (dir, version1, version2, dirPathPtr)
  112.     char        *dir;
  113.     char        *version1;
  114.     char        *version2;
  115.     Tcl_DString *dirPathPtr;
  116. {
  117.     Tcl_DStringInit (dirPathPtr);
  118.  
  119.     Tcl_DStringAppend (dirPathPtr, dir, -1);
  120.     Tcl_DStringAppend (dirPathPtr,
  121. #ifdef macintosh
  122.                     ":",
  123. #else
  124.                     "/",
  125. #endif
  126.                     -1);
  127.     if (version1 != NULL)
  128.         Tcl_DStringAppend (dirPathPtr, version1, -1);
  129.     if (version2 != NULL)
  130.         Tcl_DStringAppend (dirPathPtr, version2, -1);
  131. }
  132.  
  133. /*
  134.  *-----------------------------------------------------------------------------
  135.  * Tcl_SetLibrayDirEnvVar --
  136.  *
  137.  *   Set an library (master) directory environment variable to override
  138.  * default that Tcl or TK were compiled with.  Only overrides if the variable
  139.  * does not exist.
  140.  *
  141.  * Parameters:
  142.  *   o interp - A pointer to the interpreter.
  143.  *   o envVar (I) - Environement variable to set if it does not exist.
  144.  *   o dir (I) - The directory name.
  145.  *   o version1, version2 - Two part version number forming a directory under
  146.  *     dir.  Either maybe NULL.
  147.  *-----------------------------------------------------------------------------
  148.  */
  149. void
  150. Tcl_SetLibraryDirEnvVar (interp, envVar, dir, version1, version2)
  151.     Tcl_Interp  *interp;
  152.     char        *envVar;
  153.     char        *dir;
  154.     char        *version1;
  155.     char        *version2;
  156. {
  157.     Tcl_DString   masterDir;
  158.  
  159.     if (Tcl_GetVar (interp, envVar, TCL_GLOBAL_ONLY) != NULL)
  160.         return;
  161.  
  162.     MergeMasterDirPath (dir, version1, version2, &masterDir);
  163.     Tcl_SetVar (interp, envVar, masterDir.string, TCL_GLOBAL_ONLY);
  164.  
  165.     Tcl_DStringFree (&masterDir);
  166.  
  167. }
  168.  
  169. /*
  170.  *-----------------------------------------------------------------------------
  171.  * Tcl_ProcessInitFile --
  172.  *
  173.  *   Find and evaluate a Tcl init file.  This assumes that the init file
  174.  * lives in a master directory and appends the directory name to the 
  175.  * "auto_path" variable.
  176.  *
  177.  * Parameters:
  178.  *   o interp  (I) - A pointer to the interpreter.
  179.  *   o dirEnvVar (I) - Environment variable used to override the directory
  180.  *     path.
  181.  *   o dir (I) - The directory name.
  182.  *   o version1, version2 - Two part version number forming a directory under
  183.  *     dir.  Either maybe NULL.
  184.  *   o initFile (I) - The name of the init file, which is found either in the
  185.  *     directory pointed to by envVar or by the directory formed from dir1,
  186.  *     dir2 & dir3.
  187.  * Returns:
  188.  *   TCL_OK if all is ok, TCL_ERROR if an error occured.
  189.  *-----------------------------------------------------------------------------
  190.  */
  191. int
  192. Tcl_ProcessInitFile (interp, dirEnvVar, dir, version1, version2, initFile)
  193.     Tcl_Interp *interp;
  194.     char       *dirEnvVar;
  195.     char       *dir;
  196.     char       *version1;
  197.     char       *version2;
  198.     char       *initFile;
  199. {
  200.     char         *dirEnvValue;
  201.     Tcl_DString   filePath;
  202.     struct stat   statBuf;
  203.  
  204.     extern char *tcl_getenv();
  205.     
  206.     /*
  207.      * Determine the master (library) directory name.
  208.      */
  209. #ifdef macintosh
  210.     dirEnvValue = tcl_getenv(dirEnvVar);
  211. #else
  212.     dirEnvValue = getenv (dirEnvVar);
  213. #endif
  214.  
  215.     if (dirEnvValue != NULL) {
  216.         Tcl_DStringInit (&filePath);
  217.         Tcl_DStringAppend (&filePath, dirEnvValue, -1);
  218.     } else {
  219.         MergeMasterDirPath (dir, version1, version2, &filePath);
  220.     /*
  221.     ** Include this in the auto_path variable.
  222.     */
  223.     if ( Tcl_SetVar(interp, "auto_path", filePath.string,
  224.                     ( TCL_GLOBAL_ONLY  | TCL_APPEND_VALUE |
  225.                       TCL_LIST_ELEMENT | TCL_LEAVE_ERR_MSG ) ) == NULL )
  226.         goto errorExit;
  227.     }
  228.  
  229.     /*
  230.      * Eval the init file in that directory.
  231.      */
  232. #ifdef macintosh
  233.     Tcl_DStringAppend (&filePath, ":", -1);
  234. #else
  235.     Tcl_DStringAppend (&filePath, "/", -1);
  236. #endif
  237.     Tcl_DStringAppend (&filePath, initFile, -1);
  238.     
  239.     if (stat (filePath.string, &statBuf) < 0) {
  240.         Tcl_AppendResult (interp,
  241.                           "Can't access initialization file \"",
  242.                           filePath.string, "\".\n", 
  243.                           "  Override directory containing this file with ",
  244.                           "the environment variable: \"",
  245.                           dirEnvVar, "\"",
  246.                           (char *) NULL);
  247.         return TCL_ERROR;
  248.  
  249.     }
  250.     if (Tcl_EvalFile (interp, filePath.string) != TCL_OK)
  251.         goto errorExit;
  252.     Tcl_ResetResult (interp);
  253.  
  254.     Tcl_DStringFree (&filePath);
  255.     return TCL_OK;
  256.  
  257.   errorExit:
  258.     Tcl_DStringFree (&filePath);
  259.     return TCL_ERROR;
  260. }
  261.  
  262. /*
  263.  *-----------------------------------------------------------------------------
  264.  *
  265.  * Tcl_ShellEnvInit --
  266.  *
  267.  *   Initialize the Tcl shell environment.  Including evaluating the standard
  268.  * TclX init file and setting various variable and values for infox to access.
  269.  * If this is an interactive Tcl session, SIGINT is set to generate a Tcl
  270.  * error.  This routine is provided for the wishx shell or similar
  271.  * environments where the Tcl_Startup command line parsing is not desired.
  272.  *
  273.  * Parameters:
  274.  *   o interp - A pointer to the interpreter.
  275.  *   o options - Flags to control the behavior of this routine, the following
  276.  *     options are supported:
  277.  *       o TCLSH_INTERACTIVE - Set tcl_interactive to 1.
  278.  *       o TCLSH_QUICK_STARTUP - Don't source the Tcl initialization file.
  279.  *       o TCLSH_ABORT_STARTUP_ERR - If set, abort the process if an error
  280.  *         occurs.
  281.  *       o TCLSH_NO_STACK_DUMP - If an error occurs, don't dump out the
  282.  *         procedure call stack, just print an error message.
  283.  * Notes:
  284.  *   The variables tclAppName, tclAppLongName, tclAppVersion 
  285.  * must be set before calling thus routine if special values are desired.
  286.  *
  287.  * Returns:
  288.  *   TCL_OK if all is ok, TCL_ERROR if an error occured.
  289.  *-----------------------------------------------------------------------------
  290.  */
  291. int
  292. Tcl_ShellEnvInit (interp, options)
  293.     Tcl_Interp  *interp;
  294.     unsigned     options;
  295. {
  296.     if (Tcl_SetVar (interp, "tcl_interactive", 
  297.                     (options & TCLSH_INTERACTIVE) ? "1" : "0",
  298.                     TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL)
  299.         goto errorExit;
  300.  
  301.     tclxVersion = ckalloc (strlen (TCL_VERSION) + 
  302.                            strlen (TCL_EXTD_VERSION_SUFFIX) + 1);
  303.     strcpy (tclxVersion, TCL_VERSION);
  304.     strcat (tclxVersion, TCL_EXTD_VERSION_SUFFIX);
  305.  
  306. #ifdef PATCHLEVEL
  307.     tclxPatchlevel = PATCHLEVEL;
  308. #else
  309.     tclxPatchlevel = 0;
  310. #endif
  311.  
  312.     /*
  313.      * Set application specific values to return from the infox if they
  314.      * have not been set.
  315.      */
  316.     if (tclAppName == NULL)
  317.         tclAppName = "TclX";
  318.     if (tclAppLongname == NULL)
  319.         tclAppLongname = "Extended Tcl";
  320.     if (tclAppVersion == NULL)
  321.         tclAppVersion = tclxVersion;
  322.  
  323.     Tcl_SetLibraryDirEnvVar (interp,
  324.                              "TCL_LIBRARY",
  325.                              TCL_MASTERDIR,
  326.                              TCL_VERSION,
  327.                              TCL_EXTD_VERSION_SUFFIX);
  328.  
  329.     if ((options & TCLSH_QUICK_STARTUP) == 0) {
  330.         if (Tcl_ProcessInitFile (interp,
  331.                                  "TCL_LIBRARY",
  332.                                  TCL_MASTERDIR,
  333.                                  TCL_VERSION,
  334.                                  TCL_EXTD_VERSION_SUFFIX,
  335.                                  "TclInit.tcl") == TCL_ERROR)
  336.             goto errorExit;
  337.     }
  338. #ifndef macintosh
  339.     if (options & TCLSH_INTERACTIVE)
  340.         Tcl_SetupSigInt ();
  341. #endif
  342.     return TCL_OK;
  343.  
  344. errorExit:
  345.     if (options & TCLSH_ABORT_STARTUP_ERR)
  346.         Tcl_ErrorAbort (interp, options & TCLSH_NO_STACK_DUMP, 255);
  347.     return TCL_ERROR;
  348. }
  349.  
  350.  
  351. #ifndef macintosh
  352.  
  353. /* UNDONE - requires Tcl_CommandLoop() be ported first... */
  354.  
  355.  
  356. /*
  357.  *-----------------------------------------------------------------------------
  358.  *
  359.  * ParseCmdArgs --
  360.  *
  361.  * Parse the arguments passed to the Tcl shell.  Set the Tcl variables
  362.  * argv0, argv & argc from the remaining parameters.
  363.  *
  364.  * Parameters:
  365.  *   o interp  (I) - A pointer to the interpreter.
  366.  *   o argc, argv - Arguments passed to main.
  367.  *   o tclParmsPtr - Results of the parsed Tcl shell command line.
  368.  *-----------------------------------------------------------------------------
  369.  */
  370. static void
  371. ParseCmdArgs (interp, argc, argv, tclParmsPtr)
  372.     Tcl_Interp  *interp;
  373.     int          argc;
  374.     char       **argv;
  375.     tclParms_t  *tclParmsPtr;
  376. {
  377.     char   *scanPtr, *tclArgv, numBuf [32];
  378.     int     option;
  379.  
  380.     tclParmsPtr->execFile = FALSE;
  381.     tclParmsPtr->execCommand = FALSE;
  382.     tclParmsPtr->options = 0;
  383.     tclParmsPtr->execStr = NULL;
  384.  
  385.     /*
  386.      * Scan arguments looking for flags to process here rather than to pass
  387.      * on to the scripts.  The '-c' or '-f' must also be the last option to
  388.      * allow for script arguments starting with `-'.
  389.      */
  390.     while ((option = getopt (argc, argv, "qc:f:un")) != -1) {
  391.         switch (option) {
  392.             case 'q':
  393.                 if (tclParmsPtr->options & TCLSH_QUICK_STARTUP)
  394.                     goto usageError;
  395.                 tclParmsPtr->options |= TCLSH_QUICK_STARTUP;
  396.                 break;
  397.             case 'n':
  398.                 if (tclParmsPtr->options & TCLSH_NO_STACK_DUMP)
  399.                     goto usageError;
  400.                 tclParmsPtr->options |= TCLSH_NO_STACK_DUMP;
  401.                 break;
  402.             case 'c':
  403.                 tclParmsPtr->execCommand = TRUE;
  404.                 tclParmsPtr->execStr = optarg;
  405.                 goto exitParse;
  406.             case 'f':
  407.                 tclParmsPtr->execFile = TRUE;
  408.                 tclParmsPtr->execStr = optarg;
  409.                 goto exitParse;
  410.             case 'u':
  411.             default:
  412.                 goto usageError;
  413.         }
  414.     }
  415.     exitParse:
  416.   
  417.     /*
  418.      * If neither `-c' nor `-f' were specified and at least one parameter
  419.      * is supplied, then if is the file to execute.  The rest of the arguments
  420.      * are passed to the script.  Check for '--' as the last option, this also
  421.      * is a terminator for the file to execute.
  422.      */
  423.     if ((!tclParmsPtr->execCommand) && (!tclParmsPtr->execFile) &&
  424.         (optind != argc) && !STREQU (argv [optind-1], "--")) {
  425.         tclParmsPtr->execFile = TRUE;
  426.         tclParmsPtr->execStr = argv [optind];
  427.         optind++;
  428.     }
  429.  
  430.     /*
  431.      * Set the Tcl argv0, argv & argc variables.
  432.      */
  433.     Tcl_SetVar (interp, "argv0",
  434.                 (tclParmsPtr->execFile) ? tclParmsPtr->execStr : argv[0],
  435.                 TCL_GLOBAL_ONLY);
  436.  
  437.     tclArgv = Tcl_Merge (argc - optind,  &argv [optind]);
  438.     Tcl_SetVar (interp, "argv", tclArgv, TCL_GLOBAL_ONLY);
  439.     ckfree (tclArgv);
  440.     sprintf (numBuf, "%d", argc - optind);
  441.     Tcl_SetVar (interp, "argc", numBuf, TCL_GLOBAL_ONLY);
  442.  
  443.     return;
  444.  
  445. usageError:
  446.     fprintf (stderr, "usage: %s %s\n", argv [0],
  447.              "?-qun? ?-f? ?script?|?-c command? ?args?");
  448.     exit (1);
  449. }
  450.  
  451. /*
  452.  *-----------------------------------------------------------------------------
  453.  *
  454.  * Tcl_Startup --
  455.  *
  456.  *   Initializes the Tcl extended environment.  This function processes the
  457.  * standard command line arguments and locates the Tcl initialization file.
  458.  * It then sources the initialization file.  Either an interactive command
  459.  * loop is created or a Tcl script file is executed depending on the command
  460.  * line.  This functions calls Tcl_ShellEnvInit, so it should not be called
  461.  * separately.
  462.  *
  463.  * Parameters:
  464.  *   o interp - A pointer to the interpreter.
  465.  *   o options (I) - Options that control startup behavior.  None are
  466.  *     currently defined.
  467.  *   o argc, argv - Arguments passed to main for the command line.
  468.  * Notes:
  469.  *   The variables tclAppName, tclAppLongName, tclAppVersion must be set
  470.  * before calling thus routine if special values are desired.
  471.  *-----------------------------------------------------------------------------
  472.  */
  473. void
  474. Tcl_Startup (interp, options, argc, argv)
  475.     Tcl_Interp      *interp;
  476.     unsigned         options;
  477.     int              argc;
  478.     CONST char     **argv;
  479. {
  480.     char       *cmdBuf;
  481.     tclParms_t  tclParms;
  482.     int         result;
  483.  
  484.     /*
  485.      * Process the arguments.
  486.      */
  487.     ParseCmdArgs (interp, argc, (char **) argv, &tclParms);
  488.  
  489.     if (tclParms.execStr == NULL)
  490.         tclParms.options |= TCLSH_INTERACTIVE;
  491.  
  492.     if (Tcl_ShellEnvInit (interp, tclParms.options) != TCL_OK)
  493.         goto errorAbort;
  494.  
  495.     /*
  496.      * If the invoked tcl interactively, give the user an interactive session,
  497.      * otherwise, source the command file or execute the specified command.
  498.      */
  499.     if (tclParms.execFile) {
  500.         result = Tcl_EvalFile (interp, tclParms.execStr);
  501.         if (result != TCL_OK)
  502.             goto errorAbort;
  503.     } else if (tclParms.execCommand) {
  504.         result = Tcl_Eval (interp, tclParms.execStr);
  505.         if (result != TCL_OK)
  506.             goto errorAbort;
  507.     } else {
  508.         Tcl_CommandLoop (interp, isatty (0));
  509.     }
  510.  
  511.     Tcl_ResetResult (interp);
  512.     return;
  513.  
  514. errorAbort:
  515.     Tcl_ErrorAbort (interp, tclParms.options & TCLSH_NO_STACK_DUMP, 255);
  516. }
  517.  
  518. #endif
  519.  
  520.